(define shapes
  '(((0 0 0 0)
     (1 1 1 1))
    ((1 0 0 0)
     (1 1 1 0))
    ((0 0 1 0)
     (1 1 1 0))
    ((0 1 1 0)
     (0 1 1 0))
    ((0 1 1 0)
     (1 1 0 0))
    ((0 1 0 0)
     (1 1 1 0))
    ((1 1 0 0)
     (0 1 1 0))))


(define WORLD
  '((0 0 0 0 0 0 0 0 0 0)
   (0 0 0 0 0 0 0 0 0 0)
   (0 0 0 0 0 0 0 0 0 0)
   (0 0 0 0 0 0 0 0 0 0)
   (0 0 0 0 0 0 0 0 0 0)
   (0 0 0 0 0 0 0 0 0 0)
   (0 0 0 0 0 0 0 0 0 0)
   (0 0 0 0 0 0 0 0 0 0)
   (0 0 0 0 0 0 0 0 0 0)
   (0 0 0 0 0 0 0 0 0 0)
   (0 0 0 0 0 0 0 0 0 0)
   (0 0 0 0 0 0 0 0 0 0)
   (0 0 0 0 1 1 1 1 0 0)
   (0 0 0 0 1 1 0 1 0 0)
   (0 0 0 0 1 9 0 1 0 0)
   (0 0 0 0 1 9 0 1 0 0)
   (0 0 0 0 0 9 0 0 0 0)
   (0 0 0 0 9 9 9 0 0 0)
   (9 9 9 9 9 9 9 9 9 9)
   (0 0 0 0 0 9 0 0 0 0))
  )


(define transpose
  (lambda (LL)
    (apply (curry map list) LL)))

(transpose '((11 12 13 14)
             (21 22 23 24)
             (31 32 33 34)))

(define rotate&co
  (lambda (LL k)
    (k (map reverse (transpose LL)))))


(rotate&co '((0 1 0 0)
             (1 1 1 0))
           pretty-print)


(define ll-ref
  (lambda (LL r c)
    (list-ref (list-ref LL r) c)))
(define ll-set
  (lambda (LL r c value)
    (list-set LL r (list-set  (list-ref LL r) c value))))
(define move
  (lambda (dx dy)
    (lambda (sym-cur sym-empty LL)
      (if (= dx dy 0)
          LL
          (let* ((rows (length LL))
                 (cols (length (car LL))))
            (do ((i (- rows 1) (- i 1)))
				((< i 0))
              (do ((j (- cols 1) (- j 1)))
				  ((< j 0))
                ;; A'[i][j] <-- A[i-dy][j-dx]
                (let* ((i+ (- i dy))
                       (j+ (- j dx))
                       (x (if (and (<= 0 i+ (- rows 1)) (<= 0 j+ (- cols 1)))
                              (ll-ref LL i+ j+)
                              sym-empty)))
                  (when (eq? x sym-cur)
                    (set! LL (ll-set LL i  j  x))
                    (set! LL (ll-set LL i+ j+ sym-empty))
                    ))))
            LL)))))

(pretty-print
 ((move -1 0)
  1 0
  '((0 0 0 0)
	(0 1 1 0)
	(0 9 0 0)
	(0 0 0 0))))



(define down
  (move 0 1))





(define tetris
  (lambda (world         ;;list of list
           empty-symbol  ;;use what symbol to represent space?
           inside-symbol ;;use what symbol to represent old tetris?
           current-symbol ;;use what symbol to represent current tetris?
           command        ;; in {'a, 's, 'd, 'w}
           calc           ;;fuction that retruns new world
           k              ;;continuations
           )
    (k (calc world
             empty-symbol
             inside-symbol
             current-symbol
             command))
    ))

(define map-2d
  (lambda (f LL)
    (map
     (lambda (L)
       (map
        (lambda (x)
          (f x))
        L))
     LL)))

(define any?
  (lambda (pred . lists)
    (call/cc
     (lambda (return)
       (apply (curry map
                     (lambda args
                       (if (apply pred args)
                           (return #t)
                           #f)))
              lists
              )
       #f
       ))))

'((any? number? '(a 3 b))
  (any? = '(0 0 1 3) '(1 1 1 4))
  (any? (lambda (x y z) (= (+ x y) z)) '(1 2 3) '(4 5 6) '(5 7 9))
  (any? (lambda (x y z) (= (+ x y) z)) '(1 2 3) '(4 5 6) '(0 0 0))
  (any? (lambda (x y) (and (eq? x 1) (eq? y 9))) '(1) '(0))
  (filter
   (lambda (L)
     (any? (lambda (x) (eq? x 0)) L))
   '((0 0 0 0 1 0 1 0 0 0)
     (1 1 1 1 1 1 1 1 1 1)
     (0 0 0 0 0 1 0 0 0 0)
     (1 1 1 1 1 1 1 1 1 1))))


(define eq-c? (lambda (c) (lambda (x) (eq? x c))))
(define touchdown?
  (lambda (sym-cur sym-empty LL)
	((touch? 1 0)
	 sym-cur sym-empty LL)))


(define touch?
  (lambda (delta-j delta-i)
    (lambda (sym-cur sym-empty LL)
      (let* ((rows (length LL))
             (cols (length (car LL)))
             (max-i (- rows 1))
             (max-j (- cols 1)))
        (any?
         (lambda (ij)
           (let ((i (car ij))
                 (j (cdr ij)))
             (and (eq? (ll-ref LL i j) sym-cur)
                  (let ((forward-i (+ i delta-i))
                        (forward-j (+ j delta-j)))
                    (or (< forward-i 0)
                        (> forward-i max-i)
                        (< forward-j 0)
                        (> forward-j max-j)
                        (let ((sym-forward (ll-ref LL forward-i forward-j)))
                          (and (not (eq? sym-forward sym-cur))
                               (not (eq? sym-forward sym-empty)))))))))
         (for*/list ([i (range rows)]
                     [j (range cols)])
           (cons i j)
           ))
        ))))

((touch? 0 -1)
 1 0
 '((9 9 9)
   (9 1 0)
   (9 9 9))
 )





(define merge
  (lambda (sym-new sym-old LL k)
    (k (map-2d (lambda (x) (if (eq? x sym-new)
                               sym-old
                               x))
               LL))
    ))

'(merge 1 9 '((0 1 0)
              (1 1 1)))



(tetris
 WORLD
 0
 9
 1
 'a
 (lambda (world
          empty-symbol
          inside-symbol
          current-symbol
          command)
   (define clear-lines
     (lambda (LL)
       (let* ((cleared (filter
                        (curry any? (eq-c? empty-symbol))
                        LL))
              (lines-off (- (length LL) (length cleared)))
              (ans (append
                    (build-list
                     lines-off
                     (lambda (m)
                       (build-list
                        (length (car LL))
                        (lambda (n) empty-symbol))))
                    cleared)))
         ans)
       ))
   (define rotate
     (lambda (current-symbol empty-symbol inside-symbol world k)
       (k world)
       ))
   (define test&move
     (lambda (x y current-symbol empty-symbol inside-symbol world k)
	   (if (and (= y 1) (touchdown? current-symbol empty-symbol world))
		   (k (merge current-symbol inside-symbol world clear-lines))
		   (if ((touch? x y) current-symbol empty-symbol world)
			   (k world)
			   (k ((move x y) current-symbol empty-symbol world))))
       ))
   (cond
	 ;; 真正主体部分
	 ((eq? command 'w)
	  (rotate    current-symbol empty-symbol inside-symbol world (lambda (x) x)))
	 ((eq? command 'a)
	  (test&move -1 0 current-symbol empty-symbol inside-symbol world (lambda (x) x)))
	 ((eq? command 'd)
	  (test&move  1 0 current-symbol empty-symbol inside-symbol world (lambda (x) x)))
	 ((eq? command 's)
	  (test&move  0 1 current-symbol empty-symbol inside-symbol world (lambda (x) x)))
	 (else world)
	 ))
 pretty-print
 )






